home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / ISSUE13 / XPROCS / XPROCS.ZIP / xProcs.pas next >
Encoding:
Pascal/Delphi Source File  |  1996-07-24  |  56.9 KB  |  2,227 lines
  1. {*******************************************************}
  2. {                                                       }
  3. {       xTool - Component Collection                    }
  4. {                                                       }
  5. {       Copyright (c) 1995 Stefan B÷ther                }
  6. {                            stefc@fabula.com           }
  7. {*******************************************************}
  8. {
  9.    03.12.95  Added new RectXXXX functions from Golden Software       Stefc
  10.    03.12.95  remove confict Int with Int_                            Stefc
  11.    06.01.96  added sysTempPath and sysDelay                          Stefc
  12.    08.02.96  added dateDaysInMonth, dateYear, dateMonth, dateDay     Stefc
  13.    08.02.96  added IsWin95 constant                                  Stefc
  14.    21.02.96  added TMonth & TDay type                                Stefc
  15.    22.02.96  added strFileLoad & strFileSave                         Stefc
  16.    09.03.96  correct sysTempPath                                     Stefc
  17.    09.03.96  added regXXXXX functions for access the registry        Stefc
  18.    24.03.96  added IsWinNT constant                                  Stefc
  19.    24.03.96  added SysMetric object                                  Stefc
  20.    26.03.96  added dateQuicken for controling date input with keys   Stefc
  21.    27.03.96  added TDesktopCanvas here                               Stefc
  22.    28.03.96  added LoadDIBitmap                                      Stefc
  23.    01.04.96  added Question function here                            Stefc
  24.    09.04.96  added sysSaverRunning added                             Stefc
  25.    12.04.96  added timeZoneOffset                                    Stefc
  26.    12.04.96  added timeToInt                                         Stefc
  27.    17.04.96  added strCmdLine                                        Stefc
  28.    17.04.96  added rectBounds                                        Stefc
  29.    17.04.96  added TPersistentRect class                             Stefc
  30.    19.04.96  added strDebug method                                   Stefc
  31.    21.04.96  changed TMonth added noneMonth                          km
  32.    21.04.96  added licence callback                                  Stefc
  33.    21.04.96  added strNiceDateDefault                                km
  34.    21.04.96  added simple strEncrpyt & strDecrypt                    Stefc
  35.    24.04.96  backport to 16 bit                                      Stefc
  36.    24.04.96  added Information method                                Stefc
  37.    24.04.96  use win messageBox with Win95 in Question & Information Stefc
  38.    09.05.96  new function ExtractName                                Stefc
  39.    10.05.96  Added TPersistentRegistry                               Stefc
  40.    12.05.96  fileExec                                                Stefc
  41.    14.05.96  New function Confirmation                               Stefc
  42.    16.05.96  New function strChange                                  Stefc
  43.    29.05.96  New functions comXXXXX                                  Stefc
  44.    09.06.96  New function strSearchReplace                           km
  45.    09.06.96  ported assembler strHash to plain pascal                Stefc
  46.    15.06.96  new variables xLanguage & xLangOfs                      Stefc
  47.    28.06.96  new method sysBeep                                      Stefc
  48.    28.06.96  new method intPercent                                   Stefc
  49.    10.07.96  make compatible with 16 Bit Delphi 1.0                  Stefc
  50.    14.07.96  fileLongName & fileShortName defined                    Stefc
  51.    15.07.96  Correct sysTempPath method                              Stefc
  52.    21.07.96  New functions strContains & strContainsU                Stefc
  53. }
  54. unit xProcs;
  55.  
  56. interface
  57.  
  58. uses
  59.  {$IFDEF Win32} Windows, Registry, ShellAPI, {$ELSE} WinTypes, WinProcs, {$ENDIF}
  60.   Messages, Classes, Graphics;
  61.  
  62. type
  63.   Float = Extended;
  64.  
  65.  {$IFDEF Win32}
  66.   Int_  = Integer;
  67.  {$ELSE}
  68.   Int_  = Longint;
  69.  {$ENDIF}
  70.  
  71. const
  72.   XCOMPANY        = 'Fabula Software';
  73.  
  74. const
  75.   { several important ASCII codes }
  76.   NULL            =  #0;
  77.   BACKSPACE       =  #8;
  78.   TAB             =  #9;
  79.   LF              = #10;
  80.   CR              = #13;
  81.   EOF             = #26;
  82.   ESC             = #27;
  83.   BLANK           = #32;
  84.   SPACE           = BLANK;
  85.  
  86.   { digits as chars }
  87.   ZERO   = '0';  ONE  = '1';  TWO    = '2';  THREE  = '3';  FOUR  = '4';
  88.   FIVE   = '5';  SIX  = '6';  SEVEN  = '7';  EIGHT  = '8';  NINE  = '9';
  89.  
  90.   { special codes }
  91.   SLASH           = '\';     { used in filenames }
  92.   HEX_PREFIX      = '$';     { prefix for hexnumbers }
  93.  
  94.   CRLF            : PChar = CR+LF;
  95.  
  96.   { computer sizes }
  97.   KBYTE           = Sizeof(Byte) shl 10;
  98.   MBYTE           = KBYTE        shl 10;
  99.   GBYTE           = MBYTE        shl 10;
  100.  
  101.   { Low floating point value }
  102.   FLTZERO         : Float = 0.00000001;
  103.  
  104.  
  105.   DIGITS          : set of Char = [ZERO..NINE];
  106.  
  107.   { important registry keys / items }
  108.   REG_CURRENT_VERSION = 'Software\Microsoft\Windows\CurrentVersion';
  109.   REG_CURRENT_USER    = 'RegisteredOwner';
  110.   REG_CURRENT_COMPANY = 'RegisteredOrganization';
  111.  
  112.   PRIME_16       = 65521;
  113.   PRIME_32       = 2147483647;
  114.  
  115. type
  116.   TMonth         = (NoneMonth,January,February,March,April,May,June,July,
  117.                     August,September,October,November,December);
  118.  
  119.   TDayOfWeek    = (Sunday,Monday,Tuesday,Wednesday,Thursday,Friday,Saturday);
  120.  
  121.   { Online eMail Service Provider }
  122.   TMailProvider = (mpCServe, mpInternet, mpNone);
  123.  
  124.   TLicCallback  = function ( var Code: Integer): Integer;
  125.  
  126.   TBit          = 0..31;
  127.  
  128.   { Search and Replace options }
  129.   TSROption     = (srWord,srCase,srAll);
  130.   TSROptions    = set of TsrOption;
  131.  
  132. var
  133.   IsWin95,
  134.   IsWinNT   : Boolean;
  135.   IsFabula  : TLicCallBack;
  136.  
  137.   xLanguage : Integer;
  138.   xLangOfs  : Integer;
  139.  
  140. { bit manipulating }
  141. function bitSet(const Value: Int_; const TheBit: TBit): Boolean;
  142. function bitOn(const Value: Int_; const TheBit: TBit): Int_;
  143. function bitOff(const Value: Int_; const TheBit: TBit): Int_;
  144. function bitToggle(const Value: Int_; const TheBit: TBit): Int_;
  145.  
  146. { String functions }
  147. function  strHash(const S: String; LastBucket: Integer): Integer;
  148. function  strCut(const S: String; Len: Integer): String;
  149. function  strTrim(const S: String): String;
  150. function  strTrimA(const S: String): String;
  151. function  strTrimChA(const S: String; C: Char): String;
  152. function  strTrimChL(const S: String; C: Char): String;
  153. function  strTrimChR(const S: String; C: Char): String;
  154. function  strLeft(const S: String; Len: Integer): String;
  155. function  strLower(const S: String): String;
  156. function  strMake(C: Char; Len: Integer): String;
  157. function  strPadChL(const S: String; C: Char; Len: Integer): String;
  158. function  strPadChR(const S: String; C: Char; Len: Integer): String;
  159. function  strPadChC(const S: String; C: Char; Len: Integer): String;
  160. function  strPadL(const S: String; Len: Integer): String;
  161. function  strPadR(const S: String; Len: Integer): String;
  162. function  strPadC(const S: String; Len: Integer): String;
  163. function  strPadZeroL(const S: String; Len: Integer): String;
  164. procedure strChange(var S:String; const Source, Dest: String);
  165. function  strRight(const S: String; Len: Integer): String;
  166. function  strAddSlash(const S: String): String;
  167. function  strDelSlash(const S: String): String;
  168. function  strSpace(Len: Integer): String;
  169. function  strToken(var S: String; Seperator: Char): String;
  170. function  strTokenCount(S: String; Seperator: Char): Integer;
  171. function  strTokenAt(const S:String; Seperator: Char; At: Integer): String;
  172. function  strUpper(const S: String): String;
  173. function  strOemAnsi(const S:String): String;
  174. function  strAnsiOem(const S:String): String;
  175. function  strEqual(const S1,S2: String): Boolean;
  176. function  strComp(const S1,S2: String): Boolean;
  177. function  strCompU(const S1,S2: String): Boolean;
  178. function  strContains(const S1,S2: String): Boolean;
  179. function  strContainsU(const S1,S2: String): Boolean;
  180. function  strNiceNum(const S: String): String;
  181. function  strNiceDateDefault(const S, Default: String): String;
  182. function  strNiceDate(const S: String): String;
  183. function  strNiceTime(const S: String): String;
  184. function  strNicePhone(const S: String): String;
  185. function  strReplace(const S: String; C: Char; const Replace: String): String;
  186. function  strCmdLine: String;
  187. {$IFDEF Win32}
  188. procedure strDebug(const S: String);
  189. {$ENDIF}
  190. function  strEncrypt(const S: String; Key: Word): String;
  191. function  strDecrypt(const S: String; Key: Word): String;
  192. function  strLastCh(const S: String): Char;
  193. procedure strStripLast(var S: String);
  194. function  strByteSize(Value: Longint): String;
  195. procedure strSearchReplace(var S:String; const Source, Dest: String; Options: TSRoptions);
  196. function  strProfile(const aFile, aSection, aEntry, aDefault: String): String;
  197.  
  198. {$IFDEF Win32}
  199. function  strFileLoad(const aFile: String): String;
  200. procedure strFileSave(const aFile,aString: String);
  201. {$ENDIF}
  202.  
  203. { Integer functions }
  204. function  intCenter(a,b: Int_): Int_;
  205. function  intMax(a,b: Int_): Int_;
  206. function  intMin(a,b: Int_): Int_;
  207. function  intPow(Base,Expo: Integer): Int_;
  208. function  intPow10(Exponent: Integer): Int_;
  209. function  intSign(a: Int_): Integer;
  210. function  intZero(a: Int_; Len: Integer): String;
  211. function  intPrime(Value: Integer): Boolean;
  212. function  intPercent(a, b: Int_): Int_;
  213.  
  214. { Floatingpoint functions }
  215. function  fltAdd(P1,P2: Float; Decimals: Integer): Float;
  216. function  fltDiv(P1,P2: Float; Decimals: Integer): Float;
  217. function  fltEqual(P1,P2: Float; Decimals: Integer): Boolean;
  218. function  fltEqualZero(P: Float): Boolean;
  219. function  fltGreaterZero(P: Float): Boolean;
  220. function  fltLessZero(P: Float): Boolean;
  221. function  fltNeg(P: Float; Negate: Boolean): Float;
  222. function  fltMul(P1,P2: Float; Decimals: Integer): Float;
  223. function  fltRound(P: Float; Decimals: Integer): Float;
  224. function  fltSub(P1,P2: Float; Decimals: Integer): Float;
  225. function  fltUnEqualZero(P: Float): Boolean;
  226. function  fltCalc(const Expr: String): Float;
  227. function  fltPower(a,n: Float): Float;
  228.  
  229. { Rectangle functions from Golden Software }
  230. function  rectHeight(const R: TRect): Integer;
  231. function  rectWidth(const R: TRect): Integer;
  232. procedure rectGrow(var R: TRect; Delta: Integer);
  233. procedure rectRelativeMove(var R: TRect; DX, DY: Integer);
  234. procedure rectMoveTo(var R: TRect; X, Y: Integer);
  235. function  rectSet(Left, Top, Right, Bottom: Integer): TRect;
  236. function  rectInclude(const R1, R2: TRect): Boolean;
  237. function  rectPoint(const R: TRect; P: TPoint): Boolean;
  238. function  rectSetPoint(const TopLeft, BottomRight: TPoint): TRect;
  239. function  rectIntersection(const R1, R2: TRect): TRect;
  240. function  rectIsIntersection(const R1, R2: TRect): Boolean;
  241. function  rectIsValid(const R: TRect): Boolean;
  242. function  rectsAreValid(const Arr: array of TRect): Boolean;
  243. function  rectNull: TRect;
  244. function  rectIsNull(const R: TRect): Boolean;
  245. function  rectIsSquare(const R: TRect): Boolean;
  246. function  rectCentralPoint(const R: TRect): TPoint;
  247. function  rectBounds(aLeft,aTop,aWidth,aHeight: Integer): TRect;
  248.  
  249. { date functions }
  250. function  dateYear(D: TDateTime): Integer;
  251. function  dateMonth(D: TDateTime): Integer;
  252. function  dateDay(D: TDateTime): Integer;
  253. function  dateBeginOfYear(D: TDateTime): TDateTime;
  254. function  dateEndOfYear(D: TDateTime): TDateTime;
  255. function  dateBeginOfMonth(D: TDateTime): TDateTime;
  256. function  dateEndOfMonth(D: TDateTime): TDateTime;
  257. function  dateWeekOfYear(D: TDateTime): Integer;
  258. function  dateDayOfYear(D: TDateTime): Integer;
  259. function  dateDayOfWeek(D: TDateTime): TDayOfWeek;
  260. function  dateLeapYear(D: TDateTime): Boolean;
  261. function  dateBeginOfQuarter(D: TDateTime): TDateTime;
  262. function  dateEndOfQuarter(D: TDateTime): TDateTime;
  263. function  dateBeginOfWeek(D: TDateTime;Weekday: Integer): TDateTime;
  264. function  dateDaysInMonth(D: TDateTime): Integer;
  265. function  dateQuicken(D: TDateTime; Key: Char): TDateTime;
  266.  
  267. { time functions }
  268. function  timeHour(T: TDateTime): Integer;
  269. function  timeMin(T: TDateTime): Integer;
  270. function  timeSec(T: TDateTime): Integer;
  271. function  timeToInt(T: TDateTime): Integer;
  272.  
  273. {$IFDEF Win32}
  274. function  timeZoneOffset: Integer;
  275. {$ENDIF}
  276.  
  277. { com Functions }
  278. function  comIsCis(const S: String): Boolean;
  279. function  comIsInt(const S: String): Boolean;
  280. function  comCisToInt(const S: String): String;
  281. function  comIntToCis(const S: String): String;
  282. function  comFaxToCis(const S: String): String;
  283. function  comNormFax(const Name,Fax: String): String;
  284. function  comNormPhone(const Phone: String): String;
  285. function  comNormInt(const Name,Int: String): String;
  286. function  comNormCis(const Name,Cis: String): String;
  287.  
  288. { file functions }
  289. procedure fileShredder(const Filename: String);
  290. function  fileSize(const Filename: String): Longint;
  291. function  fileWildcard(const Filename: String): Boolean;
  292.  
  293. {$IFDEF Win32}
  294. function  fileTemp(const aExt: String): String;
  295. function  fileExec(const aCmdLine: String; aHide, aWait: Boolean): Boolean;
  296. function  fileLongName(const aFile: String): String;
  297. function  fileShortName(const aFile: String): String;
  298. {$ENDIF}
  299. function  ExtractName(const Filename: String): String;
  300.  
  301. { system functions }
  302. function  sysTempPath:String;
  303. procedure sysDelay(aMs: Longint);
  304. procedure sysBeep;
  305.  
  306. {$IFDEF Win32}
  307. procedure sysSaverRunning(Active: Boolean);
  308. {$ENDIF}
  309.  
  310. { registry functions }
  311.  
  312. {$IFDEF Win32}
  313. function  regReadString(aKey: hKey; const Path: String): String;
  314. procedure regWriteString(aKey: hKey; const Path,Value: String);
  315. function  regInfoString(const Value: String): String;
  316. function  regCurrentUser: String;
  317. function  regCurrentCompany: String;
  318. {$ENDIF}
  319.  
  320. { several functions }
  321. function  Question(const Msg: String):Boolean;
  322. procedure Information(const Msg: String);
  323. function  Confirmation(const Msg: String): Word;
  324.  
  325. type
  326.   { TRect that can be used persistent as property for components }
  327.   TUnitConvertEvent = function (Sender: TObject;
  328.     Value: Integer; Get: Boolean): Integer of object;
  329.  
  330.   TPersistentRect = class(TPersistent)
  331.   private
  332.     FRect      : TRect;
  333.     FOnConvert : TUnitConvertEvent;
  334.     procedure SetLeft(Value: Integer);
  335.     procedure SetTop(Value: Integer);
  336.     procedure SetHeight(Value: Integer);
  337.     procedure SetWidth(Value: Integer);
  338.     function  GetLeft: Integer;
  339.     function  GetTop: Integer;
  340.     function  GetHeight: Integer;
  341.     function  GetWidth: Integer;
  342.   public
  343.     constructor Create;
  344.     procedure Assign(Source: TPersistent); override;
  345.     property Rect: TRect read FRect;
  346.     property OnConvert: TUnitConvertEvent read FOnConvert write FOnConvert;
  347.   published
  348.     property Left  : Integer read GetLeft   write SetLeft;
  349.     property Top   : Integer read GetTop    write SetTop;
  350.     property Height: Integer read GetHeight write SetHeight;
  351.     property Width : Integer read GetWidth  write SetWidth;
  352.   end;
  353.  
  354. {$IFDEF Win32}
  355.   { Persistent access of components from the registry }
  356.   TPersistentRegistry = class(TRegistry)
  357.   public
  358.     function  ReadComponent(const Name: String; Owner, Parent: TComponent): TComponent;
  359.     procedure WriteComponent(const Name: String; Component: TComponent);
  360.   end;
  361. {$ENDIF
  362.  
  363.   { easy access of the system metrics }
  364.   TSystemMetric = class
  365.   private
  366.     FMenuHeight,
  367.     FCaptionHeight : Integer;
  368.     FBorder,
  369.     FFrame,
  370.     FDlgFrame,
  371.     FBitmap,
  372.     FHScroll,
  373.     FVScroll,
  374.     FThumb,
  375.     FFullScreen,
  376.     FMin,
  377.     FMinTrack,
  378.     FCursor,
  379.     FIcon,
  380.     FDoubleClick,
  381.     FIconSpacing : TPoint;
  382.   protected
  383.     constructor Create;
  384.     procedure Update;
  385.   public
  386.     property MenuHeight: Integer read FMenuHeight;
  387.     property CaptionHeight: Integer read FCaptionHeight;
  388.     property Border: TPoint read FBorder;
  389.     property Frame: TPoint read FFrame;
  390.     property DlgFrame: TPoint read FDlgFrame;
  391.     property Bitmap: TPoint read FBitmap;
  392.     property HScroll: TPoint read FHScroll;
  393.     property VScroll: TPoint read FVScroll;
  394.     property Thumb: TPoint read FThumb;
  395.     property FullScreen: TPoint read FFullScreen;
  396.     property Min: TPoint read FMin;
  397.     property MinTrack: TPoint read FMinTrack;
  398.     property Cursor: TPoint read FCursor;
  399.     property Icon: TPoint read FIcon;
  400.     property DoubleClick: TPoint read FDoubleClick;
  401.     property IconSpacing: TPoint read FIconSpacing;
  402.   end;
  403.  
  404. var
  405.   SysMetric: TSystemMetric;
  406.  
  407. type
  408.   TDesktopCanvas = class(TCanvas)
  409.   private
  410.     DC           : hDC;
  411.   public
  412.     constructor  Create;
  413.     destructor   Destroy; override;
  414.   end;
  415.  
  416. implementation
  417.  
  418. uses
  419.   SysUtils, Controls, Forms, Consts,
  420.   Dialogs;
  421.  
  422. { bit manipulating }
  423. function bitSet(const Value: Int_; const TheBit: TBit): Boolean;
  424. begin
  425.   Result:= (Value and (1 shl TheBit)) <> 0;
  426. end;
  427.  
  428. function bitOn(const Value: Int_; const TheBit: TBit): Int_;
  429. begin
  430.   Result := Value or (1 shl TheBit);
  431. end;
  432.  
  433. function bitOff(const Value: Int_; const TheBit: TBit): Int_;
  434. begin
  435.   Result := Value and ((1 shl TheBit) xor $FFFFFFFF);
  436. end;
  437.  
  438. function bitToggle(const Value: Int_; const TheBit: TBit): Int_;
  439. begin
  440.   result := Value xor (1 shl TheBit);
  441. end;
  442.  
  443. { string methods }
  444.  
  445. function strHash(const S: String; LastBucket: Integer): Integer;
  446. var
  447.   i: Integer;
  448. begin
  449.   Result:=0;
  450.   for i := 1 to Length(S) do
  451.     Result := ((Result shl 3) xor Ord(S[i])) mod LastBucket;
  452. end;
  453.  
  454. function strTrim(const S: String): String;
  455. begin
  456.   Result:=StrTrimChR(StrTrimChL(S,BLANK),BLANK);
  457. end;
  458.  
  459. function strTrimA(const S: String): String;
  460. begin
  461.   Result:=StrTrimChA(S,BLANK);
  462. end;
  463.  
  464. function strTrimChA(const S: String; C: Char): String;
  465. var
  466.   I               : Word;
  467. begin
  468.   Result:=S;
  469.   for I:=Length(Result) downto 1 do
  470.     if Result[I]=C then Delete(Result,I,1);
  471. end;
  472.  
  473. function strTrimChL(const S: String; C: Char): String;
  474. begin
  475.   Result:=S;
  476.   while (Length(Result)>0) and (Result[1]=C) do Delete(Result,1,1);
  477. end;
  478.  
  479. function strTrimChR(const S: String; C: Char): String;
  480. begin
  481.   Result:=S;
  482.   while (Length(Result)> 0) and (Result[Length(Result)]=C) do
  483.     Delete(Result,Length(Result),1);
  484. end;
  485.  
  486. function strLeft(const S: String; Len: Integer): String;
  487. begin
  488.   Result:=Copy(S,1,Len);
  489. end;
  490.  
  491. function strLower(const S: String): String;
  492. begin
  493.   Result:=AnsiLowerCase(S);
  494. end;
  495.  
  496. function strMake(C: Char; Len: Integer): String;
  497. begin
  498.   Result:=strPadChL('',C,Len);
  499. end;
  500.  
  501. function strPadChL(const S: String; C: Char; Len: Integer): String;
  502. begin
  503.   Result:=S;
  504.   while Length(Result)<Len do Result:=C+Result;
  505. end;
  506.  
  507. function strPadChR(const S: String; C: Char; Len: Integer): String;
  508. begin
  509.   Result:=S;
  510.   while Length(Result)<Len do Result:=Result+C;
  511. end;
  512.  
  513. function strPadChC(const S: String; C: Char; Len: Integer): String;
  514. begin
  515.   Result:=S;
  516.   while Length(Result)<Len do
  517.   begin
  518.     Result:=Result+C;
  519.     if Length(Result)<Len then Result:=C+Result;
  520.   end;
  521. end;
  522.  
  523. function strPadL(const S: String; Len: Integer): String;
  524. begin
  525.   Result:=strPadChL(S,BLANK,Len);
  526. end;
  527.  
  528. function strPadC(const S: String; Len: Integer): String;
  529. begin
  530.   Result:=strPadChC(S,BLANK,Len);
  531. end;
  532.  
  533.  
  534. function strPadR(const S: String; Len: Integer): String;
  535. begin
  536.   Result:=strPadChR(S,BLANK,Len);
  537. end;
  538.  
  539. function strPadZeroL(const S: String; Len: Integer): String;
  540. begin
  541.   Result:=strPadChL(strTrim(S),ZERO,Len);
  542. end;
  543.  
  544. function strCut(const S: String; Len: Integer): String;
  545. begin
  546.   Result:=strLeft(strPadR(S,Len),Len);
  547. end;
  548.  
  549. function strRight(const S: String; Len: Integer): String;
  550. begin
  551.   if Len>=Length(S) then
  552.     Result:=S
  553.   else
  554.     Result:=Copy(S,Succ(Length(S))-Len,Len);
  555. end;
  556.  
  557. function strAddSlash(const S: String): String;
  558. begin
  559.   Result:=S;
  560.   if strLastCh(Result)<>SLASH then Result:=Result+SLASH;
  561. end;
  562.  
  563. function strDelSlash(const S: String): String;
  564. begin
  565.   Result:=S;
  566.   if strLastCh(Result)=SLASH then Delete(Result,Length(Result),1);
  567. end;
  568.  
  569. function strSpace(Len: Integer): String;
  570. begin
  571.   Result:=StrMake(BLANK,Len);
  572. end;
  573.  
  574. function strToken(var S: String; Seperator: Char): String;
  575. var
  576.   I               : Word;
  577. begin
  578.   I:=Pos(Seperator,S);
  579.   if I<>0 then
  580.   begin
  581.     Result:=System.Copy(S,1,I-1);
  582.     System.Delete(S,1,I);
  583.   end else
  584.   begin
  585.     Result:=S;
  586.     S:='';
  587.   end;
  588. end;
  589.  
  590. function strTokenCount(S: String; Seperator: Char): Integer;
  591. begin
  592.   Result:=0;
  593.   while StrToken(S,Seperator)<>'' do Inc(Result);
  594. end;
  595.  
  596. function strTokenAt(const S:String; Seperator: Char; At: Integer): String;
  597. var
  598.   j,i: Integer;
  599. begin
  600.   Result:='';
  601.   j := 1;
  602.   i := 0;
  603.   while (i<=At ) and (j<=Length(S)) do
  604.   begin
  605.     if S[j]=Seperator then
  606.        Inc(i)
  607.     else if i = At then
  608.        Result:=Result+S[j];
  609.     Inc(j);
  610.   end;
  611. end;
  612.  
  613. function strUpper(const S: String): String;
  614. begin
  615.   Result:=AnsiUpperCase(S);
  616. end;
  617.  
  618. function strOemAnsi(const S:String):String;
  619. begin
  620.  {$IFDEF Win32}
  621.   SetLength(Result,Length(S));
  622.  {$ELSE}
  623.   Result[0]:=Chr(Length(S));
  624.  {$ENDIF}
  625.   OemToAnsiBuff(@S[1],@Result[1],Length(S));
  626. end;
  627.  
  628. function strAnsiOem(const S:String): String;
  629. begin
  630.  {$IFDEF Win32}
  631.   SetLength(Result,Length(S));
  632.  {$ELSE}
  633.   Result[0]:=Chr(Length(S));
  634.  {$ENDIF}
  635.   AnsiToOemBuff(@S[1],@Result[1],Length(S));
  636. end;
  637.  
  638. function strEqual(const S1,S2: String): Boolean;
  639. begin
  640.   Result:=AnsiCompareText(S1,S2)=0;
  641. end;
  642.  
  643. function strCompU(const S1,S2: String) : Boolean;
  644. begin
  645.   Result:=strEqual(strLeft(S2,Length(S1)),S1);
  646. end;
  647.  
  648. function strComp(const S1,S2: String) : Boolean;
  649. begin
  650.   Result:=strLeft(S2,Length(S1))=S1;
  651. end;
  652.  
  653. function strContains(const S1,S2: String): Boolean;
  654. begin
  655.   Result:=Pos(S1,S2) > 0;
  656. end;
  657.  
  658. function strContainsU(const S1,S2: String): Boolean;
  659. begin
  660.   Result:=strContains(strUpper(S1),strUpper(S2));
  661. end;
  662.  
  663.  
  664. function strNiceNum(const S: String) : String;
  665. var
  666.   i    : Integer;
  667.   Seps : set of Char;
  668. begin
  669.   Seps:=[ThousandSeparator,DecimalSeparator];
  670.   Result:= ZERO;
  671.   for i := 1 to Length(S) do
  672.     if S[i] in DIGITS + Seps then
  673.     begin
  674.       if S[i] = ThousandSeparator then
  675.          Result:=Result+DecimalSeparator
  676.       else
  677.          Result:=Result+S[i];
  678.       if S[i] In Seps then Seps:=[];
  679.     end
  680. end;
  681.  
  682. function strNiceDate(const S: String): String;
  683. begin
  684.   Result:=strNiceDateDefault(S, DateToStr(Date));
  685. end;
  686.  
  687. function  strNiceDateDefault(const S, Default: String): String;
  688. (* sinn der Procedure:
  689.    Irgendeinen String ⁿbergeben und in ein leidlich brauchbares Datum verwandeln.
  690.    Im Wesentlichen zum Abfangen des Kommazeichens auf dem Zehnerfeld.
  691.    eingabe 10 = Rⁿckgabe 10 des Laufenden Monats
  692.    eingabe 10.12 = Rⁿckgabe des 10.12. des laufenden Jahres.
  693.    eingabe 10.12.96 = Rⁿckgabe des Strings
  694.    eingabe 10,12,96 = Rⁿckgabe 10.12.95 (wird dann won STRtoDATE() gefressen)
  695.    Eine PlausbilitΣtskontrolle des Datums findet nicht Statt.
  696.    Geplante Erweiterung:
  697.    eingabe: +14  = Rⁿckgabe 14 Tage Weiter
  698.    eingabe: +3m  = Rⁿckgabe 3 Monate ab Heute
  699.    eingabe: +3w  = Rⁿckgabe 3 Wochen (3*7 Tage) ab Heute
  700.    Das gleiche auch RⁿckwΣrts mit  Minuszeichen
  701.    eingabe: e oder E oder f  = NΣchster Erster
  702.    eingabe: e+1m Erster des ⁿbernΣchsten Monats
  703.    Da lΣ▀t sich aber noch trefflich weiterspinnen
  704.  
  705.    EV. mit Quelle rausgeben, damit sich die EnglΣnder und Franzosen an
  706.    Ihren Datumsformaten selbst erfreuen k÷nnen und wir die passenden umsetzungen
  707.    bekommen. *)
  708. var
  709.   a        : array [0..2] of string[4];
  710.   heute    : string;
  711.   i,j      : integer;
  712. begin
  713.   a[0]:='';
  714.   a[1]:='';
  715.   a[2]:='';
  716.   heute := Default;
  717.  
  718.   j := 0;
  719.   for i := 0 to length(S) do
  720.     if S[i] in DIGITS then
  721.       a[j] := a[j]+S[i]
  722.     else if S[i] in [DateSeparator] then Inc(j);
  723.   for i := 0 to 2 do
  724.   if Length(a[i]) = 0 then
  725.     if I=2 then
  726.       a[i] :=copy(heute,i*3+1,4)
  727.     else
  728.       a[i] := copy(heute,i*3+1,2)
  729.   else
  730.     if length(a[i]) = 1 then
  731.       a[i] := '0'+a[i];
  732.  
  733.   Result:=a[0]+DateSeparator+a[1]+DateSeparator+a[2];
  734.   try
  735.     StrToDate(Result);
  736.   except
  737.     Result:=DateToStr(Date);
  738.   end;
  739. end;
  740.  
  741. function strNiceTime(const S: String): String;
  742. var
  743.   a   : array[0..2] of string[2];
  744.   i,j : integer;
  745. begin
  746.   j:= 0;
  747.   a[0]:= '';
  748.   a[1]:='';
  749.   a[2]:='';
  750.   for i:= 1 to length(S) do
  751.   begin
  752.     if S[i] in DIGITS then
  753.     begin
  754.       a[j] := a[j]+S[i];
  755.     end
  756.     else if S[i] in ['.',',',':'] then
  757.       inc(J);
  758.     if j > 2 then exit;
  759.   end;
  760.   for J := 0 to 2 do
  761.     if length(a[j]) = 1 then a[j] := '0'+a[j] else
  762.     if length(a[j]) = 0 then a[j] := '00';
  763.   Result := a[0]+TimeSeparator+a[1]+TimeSeparator+a[2];
  764. end;
  765.  
  766. function strNicePhone(const S: String): String;
  767. var
  768.   L : Integer;
  769. begin
  770.   if Length(S) > 3 then
  771.   begin
  772.     L:=(Length(S)+1) div 2;
  773.     Result:=strNicePhone(strLeft(S,L))+SPACE+strNicePhone(strRight(S,Length(S)-L));
  774.   end else
  775.     Result := S;
  776. end;
  777.  
  778. function strReplace(const S: String; C: Char; const Replace: String): String;
  779. var
  780.   i : Integer;
  781. begin
  782.   Result:='';
  783.   for i:=Length(S) downto 1 do
  784.     if S[i]=C then Result:=Replace+Result
  785.               else Result:=S[i]+Result;
  786. end;
  787.  
  788. procedure strChange(var S:String; const Source, Dest: String);
  789. var
  790.   P : Integer;
  791. begin
  792.   P:=Pos(Source,S);
  793.   while P<>0 do
  794.   begin
  795.     Delete(S,P,Length(Source));
  796.     Insert(Dest,S,P);
  797.     P:=Pos(Source,S);
  798.   end;
  799. end;
  800.  
  801. function strCmdLine: String;
  802. var
  803.   i: Integer;
  804. begin
  805.   Result:='';
  806.   for i:=1 to ParamCount do Result:=Result+ParamStr(i)+' ';
  807.   Delete(Result,Length(Result),1);
  808. end;
  809.  
  810. { sends a string to debug windows inside the IDE }
  811. {$IFDEF Win32}
  812. procedure strDebug(const S: String);
  813. var
  814.   P    : PChar;
  815.   CPS  : TCopyDataStruct;
  816.   aWnd : hWnd;
  817. begin
  818.   aWnd := FindWindow('TfrmDbgTerm', nil);
  819.   if aWnd <> 0 then
  820.   begin
  821.     CPS.cbData := Length(S) + 2;
  822.     GetMem(P, CPS.cbData);
  823.     try
  824.       StrPCopy(P, S+CR);
  825.       CPS.lpData := P;
  826.       SendMessage(aWnd, WM_COPYDATA, 0, LParam(@CPS));
  827.     finally
  828.       FreeMem(P, Length(S)+2);
  829.     end;
  830.   end;
  831. end;
  832. {$ENDIF}
  833.  
  834. function strByteSize(Value: Longint): String;
  835.  
  836.   function FltToStr(F: Extended): String;
  837.   begin
  838.     Result:=FloatToStrF(F,ffNumber,6,0);
  839.   end;
  840.   
  841. begin
  842.   if Value > GBYTE then
  843.     Result:=FltTostr(Value / GBYTE)+' GB'
  844.   else if Value > MBYTE then
  845.     Result:=FltToStr(Value / MBYTE)+' MB'
  846.   else
  847.     Result:=FltTostr(Value / KBYTE)+' KB';
  848. end;
  849.  
  850.  
  851. const
  852.   C1 = 52845;
  853.   C2 = 22719;
  854.  
  855. function strEncrypt(const S: String; Key: Word): String;
  856. var
  857.   I: Integer;
  858. begin
  859.  {$IFDEF Win32}
  860.   SetLength(Result,Length(S));
  861.  {$ELSE}
  862.    Result[0]:=Chr(Length(S));
  863.  {$ENDIF}
  864.   for I := 1 to Length(S) do begin
  865.     Result[I] := Char(Ord(S[I]) xor (Key shr 8));
  866.     Key := (Ord(Result[I]) + Key) * C1 + C2;
  867.   end;
  868. end;
  869.  
  870. function strDecrypt(const S: String; Key: Word): String;
  871. var
  872.   I: Integer;
  873. begin
  874.  {$IFDEF Win32}
  875.   SetLength(Result,Length(S));
  876.  {$ELSE}
  877.    Result[0]:=Chr(Length(S));
  878.  {$ENDIF}
  879.   for I := 1 to Length(S) do begin
  880.     Result[I] := char(Ord(S[I]) xor (Key shr 8));
  881.     Key := (Ord(S[I]) + Key) * C1 + C2;
  882.   end;
  883. end;
  884.  
  885. function  strLastCh(const S: String): Char;
  886. begin
  887.   Result:=S[Length(S)];
  888. end;
  889.  
  890. procedure strStripLast(var S: String);
  891. begin
  892.   if Length(S) > 0 then Delete(S,Length(S),1);
  893. end;
  894.  
  895. procedure strSearchReplace(var S:String; const Source, Dest: String; Options: TSRoptions);
  896. var hs,hs1,hs2,hs3: String;
  897. var i,j : integer;
  898.  
  899. begin
  900.  if  srCase in Options then
  901.   begin
  902.    hs := s;
  903.    hs3 := source;
  904.   end
  905.  else 
  906.   begin
  907.    hs:= StrUpper(s);
  908.    hs3 := StrUpper(Source);
  909.   end;
  910.  hs1:= '';
  911.  I:= pos(hs3,hs);
  912.  j := length(hs3);
  913.  while i > 0 do
  914.  begin
  915.    delete(hs,1,i+j-1); {Anfang Rest geΣndert 8.7.96 KM}
  916.    hs1 := Hs1+copy(s,1,i-1); {Kopieren geΣndert 8.7.96 KM}
  917.    delete(s,1,i-1); {L÷schen bis Anfang posgeΣndert 8.7.96 KM}
  918.    hs2 := copy(s,1,j); {Bis ende pos Sichern}
  919.    delete(s,1,j); {L÷schen bis ende Pos}
  920.    if    (not (srWord in Options))
  921.        or (pos(s[1],' .,:;-#''+*?=)(/&%$º"!{[]}\~<>|') > 0) then
  922.     begin
  923.      {Quelle durch ziel erstzen}
  924.      hs1 := hs1+dest;
  925.     end
  926.    else
  927.     begin
  928.      hs1 := hs1+hs2;
  929.     end;
  930.    if srall in options then
  931.     I:= pos(hs3,hs)
  932.    else
  933.     i :=0;
  934.   end;
  935.   s:= hs1+s;
  936. end;
  937.  
  938. function  strProfile(const aFile, aSection, aEntry, aDefault: String): String;
  939. var
  940.   aTmp: array[0..255] of Char;
  941. begin
  942.  {$IFDEF Win32}
  943.    GetPrivateProfileString(PChar(aSection), PChar(aEntry),
  944.       PChar(aDefault), aTmp, Sizeof(aTmp)-1, PChar(aFile));
  945.    Result:=StrPas(aTmp);
  946.  {$ENDIF}
  947. end;
  948.  
  949. {$IFDEF Win32}
  950. function strFileLoad(const aFile: String): String;
  951. var
  952.   aStr : TStrings;
  953. begin
  954.   Result:='';
  955.   aStr:=TStringList.Create;
  956.   try
  957.     aStr.LoadFromFile(aFile);
  958.     Result:=aStr.Text;
  959.   finally
  960.     aStr.Free;
  961.   end;
  962. end;
  963.  
  964. procedure strFileSave(const aFile,aString: String);
  965. var
  966.   Stream: TStream;
  967. begin
  968.   Stream := TFileStream.Create(aFile, fmCreate);
  969.   try
  970.     Stream.WriteBuffer(Pointer(aString)^,Length(aString));
  971.   finally
  972.     Stream.Free;
  973.   end;
  974. end;
  975. {$ENDIF}
  976.  
  977. { Integer stuff }
  978.  
  979. function IntCenter(a,b: Int_): Int_;
  980. begin
  981.   Result:=a div 2 - b div 2;
  982. end;
  983.  
  984. function IntMax(a,b: Int_): Int_;
  985. begin
  986.   if a>b then Result:=a else Result:=b;
  987. end;
  988.  
  989. function IntMin(a,b: Int_): Int_;
  990. begin
  991.   if a<b then Result:=a else Result:=b;
  992. end;
  993.  
  994. function IntPow(Base,Expo: Integer): Int_;
  995. var
  996.   Loop             : Word;
  997. begin
  998.   Result:=1;
  999.   for Loop:=1 to Expo do Result:=Result*Base;
  1000. end;
  1001.  
  1002. function IntPow10(Exponent: Integer): Int_;
  1003. begin
  1004.   Result:=IntPow(10,Exponent);
  1005. end;
  1006.  
  1007. function IntSign(a: Int_): Integer;
  1008. begin
  1009.   if a<0 then Result:=-1 else if a>0 then Result:=+1 else Result:= 0;
  1010. end;
  1011.  
  1012. function IntZero(a: Int_; Len: Integer): String;
  1013. begin
  1014.   Result:=strPadZeroL(IntToStr(a),Len);
  1015. end;
  1016.  
  1017. function IntPrime(Value: Integer): Boolean;
  1018. var
  1019.   i : integer;
  1020. begin
  1021.   Result:=False;
  1022.   if Value mod 2 <> 0 then
  1023.   begin
  1024.     i := 1;
  1025.     repeat
  1026.       i := i + 2;
  1027.       Result:= Value mod i = 0
  1028.     until Result or ( i > Trunc(sqrt(Value)) );
  1029.     Result:= not Result;
  1030.   end;
  1031. end;
  1032.  
  1033. function IntPercent(a, b : Int_): Int_;
  1034. begin
  1035.   Result := Trunc((a / b)*100);
  1036. end;
  1037.  
  1038. { Floating point stuff }
  1039.  
  1040. function FltAdd(P1,P2: Float; Decimals: Integer): Float;
  1041. begin
  1042.   P1    :=fltRound(P1,Decimals);
  1043.   P2    :=fltRound(P2,Decimals);
  1044.   Result:=fltRound(P1+P2,Decimals);
  1045. end;
  1046.  
  1047. function FltDiv(P1,P2: Float; Decimals: Integer): Float;
  1048. begin
  1049.   P1:=fltRound(P1,Decimals);
  1050.   P2:=fltRound(P2,Decimals);
  1051.   if P2=0.0 then P2:=FLTZERO;       { provide division by zero }
  1052.   Result:=fltRound(P1/P2,Decimals);
  1053. end;
  1054.  
  1055. function FltEqual(P1,P2: Float; Decimals: Integer): Boolean;
  1056. var
  1057.   Diff            : Float;
  1058. begin
  1059.   Diff:=fltSub(P1,P2,Decimals);
  1060.   Result:=fltEqualZero(Diff);
  1061. end;
  1062.  
  1063. function FltEqualZero(P: Float): Boolean;
  1064. begin
  1065.   Result:=(P>-FLTZERO) and (P<FLTZERO);
  1066. end;
  1067.  
  1068. function FltGreaterZero(P: Float): Boolean;
  1069. begin
  1070.   Result:=P>FLTZERO;
  1071. end;
  1072.  
  1073. function FltLessZero(P: Float): Boolean;
  1074. begin
  1075.   Result:=P<-FLTZERO;
  1076. end;
  1077.  
  1078. function FltNeg(P: Float; Negate: Boolean): Float;
  1079. begin
  1080.   if Negate then Result:=-P else Result:=P;
  1081. end;
  1082.  
  1083. function FltMul(P1,P2: Float; Decimals: Integer): Float;
  1084. begin
  1085.   P1    :=fltRound(P1,Decimals);
  1086.   P2    :=fltRound(P2,Decimals);
  1087.   Result:=fltRound(P1*P2,Decimals);
  1088. end;
  1089.  
  1090. function FltRound(P: Float; Decimals: Integer): Float;
  1091. var
  1092.   Factor  : LongInt;
  1093.   Help    : Float;
  1094. begin
  1095.   Factor:=IntPow10(Decimals);
  1096.   if P<0 then Help:=-0.5 else Help:=0.5;
  1097.   Result:=Int(P*Factor+Help)/Factor;
  1098.   if fltEqualZero(Result) then Result:=0.00;
  1099. end;
  1100.  
  1101. function FltSub(P1,P2: Float; Decimals: Integer): Float;
  1102. begin
  1103.   P1    :=fltRound(P1,Decimals);
  1104.   P2    :=fltRound(P2,Decimals);
  1105.   Result:=fltRound(P1-P2,Decimals);
  1106. end;
  1107.  
  1108. function FltUnEqualZero(P: Float): Boolean;
  1109. begin
  1110.   Result:=(P<-FLTZERO) or (P>FLTZERO)
  1111. end;
  1112.  
  1113. function FltCalc(const Expr: String): Float;
  1114. const
  1115.   STACKSIZE = 10;
  1116. var
  1117.   Stack   : array[0..STACKSIZE] of double;
  1118.   oStack  : array[0..STACKSIZE] of char;
  1119.   z,n     : double;
  1120.   i,j,m   : integer;
  1121.   Bracket : boolean;
  1122. begin
  1123.   Bracket:= False; j := 0; n:= 1;z:=0; m:=1;
  1124.   for i := 1 to Length(Expr) do
  1125.   begin
  1126.     if not Bracket  then
  1127.        case Expr[i] of
  1128.          '0' .. '9': begin
  1129.                        z:=z*10+ord(Expr[i])-ord('0');
  1130.                        n:=n*m;
  1131.                      end;
  1132.          ',',#46   : m := 10;
  1133.          '('       : Bracket := True; {hier Klammeranfang merken, ZΣhler!!}
  1134.          '*','x',
  1135.          'X',
  1136.          '/','+'   : begin
  1137.                        Stack[j] := z/n;
  1138.                        oStack[j] := Expr[i];
  1139.                        Inc(j);
  1140.                        m:=1;z:=0;n:=1;
  1141.                      end;
  1142.        end {case}
  1143.     else
  1144.        Bracket:= Expr[i]<> ')'; {hier Rekursiver Aufruf, ZΣhler !!};
  1145.   end;
  1146.   Stack[j] := z/n;
  1147.   for i := 1 to j do
  1148.     case oStack[i-1] of
  1149.       '*','x','X' :  Stack[i]:= Stack[i-1]*Stack[i];
  1150.       '/'         :  Stack[i]:= Stack[i-1]/Stack[i];
  1151.       '+'         :  Stack[i]:= Stack[i-1]+Stack[i];
  1152.     end;
  1153.   Result:= Stack[j];
  1154. end;
  1155.  
  1156. function fltPower(a, n: Float): Float;
  1157. begin
  1158.   Result:=Exp(n * Ln(a));
  1159. end;
  1160.  
  1161. { Rectangle Calculations }
  1162.  
  1163. function RectHeight(const R: TRect): Integer;
  1164. begin
  1165.   Result := R.Bottom - R.Top;
  1166. end;
  1167.  
  1168. function RectWidth(const R: TRect): Integer;
  1169. begin
  1170.   Result := R.Right - R.Left;
  1171. end;
  1172.  
  1173. procedure RectGrow(var R: TRect; Delta: Integer);
  1174. begin
  1175.   with R do
  1176.   begin
  1177.     Dec(Left, Delta);
  1178.     Dec(Top, Delta);
  1179.     Inc(Right, Delta);
  1180.     Inc(Bottom, Delta);
  1181.   end;
  1182. end;
  1183.  
  1184. procedure RectRelativeMove(var R: TRect; DX, DY: Integer);
  1185. begin
  1186.   with R do
  1187.   begin
  1188.     Inc(Left, DX);
  1189.     Inc(Right, DX);
  1190.     Inc(Top, DY);
  1191.     Inc(Bottom, DY);
  1192.   end;
  1193. end;
  1194.  
  1195. procedure RectMoveTo(var R: TRect; X, Y: Integer);
  1196. begin
  1197.   with R do
  1198.   begin
  1199.     Right := X + Right - Left;
  1200.     Bottom := Y + Bottom - Top;
  1201.     Left := X;
  1202.     Top := Y;
  1203.   end;
  1204. end;
  1205.  
  1206. function RectSet(Left, Top, Right, Bottom: Integer): TRect;
  1207. begin
  1208.   Result.Left := Left;
  1209.   Result.Top := Top;
  1210.   Result.Right := Right;
  1211.   Result.Bottom := Bottom;
  1212. end;
  1213.  
  1214. function RectSetPoint(const TopLeft, BottomRight: TPoint): TRect;
  1215. begin
  1216.   Result.TopLeft := TopLeft;
  1217.   Result.BottomRight := BottomRight;
  1218. end;
  1219.  
  1220. function RectInclude(const R1, R2: TRect): Boolean;
  1221. begin
  1222.   Result := (R1.Left >= R2.Left) and (R1.Top >= R2.Top)
  1223.     and (R1.Right <= R2.Right) and (R1.Bottom <= R2.Bottom);
  1224. end;
  1225.  
  1226. function  RectPoint(const R: TRect; P: TPoint): Boolean;
  1227. begin
  1228.   Result := (p.x>r.left) and (p.x<r.right) and (p.y>r.top) and (p.y<r.bottom);
  1229. end;
  1230.  
  1231. function RectIntersection(const R1, R2: TRect): TRect;
  1232. begin
  1233.   with Result do
  1234.   begin
  1235.     Left := intMax(R1.Left, R2.Left);
  1236.     Top := intMax(R1.Top, R2.Top);
  1237.     Right := intMin(R1.Right, R2.Right);
  1238.     Bottom := intMin(R1.Bottom, R2.Bottom);
  1239.   end;
  1240.  
  1241.   if not RectIsValid(Result) then
  1242.     Result := RectSet(0, 0, 0, 0);
  1243. end;
  1244.  
  1245. function RectIsIntersection(const R1, R2: TRect): Boolean;
  1246. begin
  1247.   Result := not RectIsNull(RectIntersection(R1, R2));
  1248. end;
  1249.  
  1250. function RectIsValid(const R: TRect): Boolean;
  1251. begin
  1252.   with R do
  1253.     Result := (Left <= Right) and (Top <= Bottom);
  1254. end;
  1255.  
  1256. function RectsAreValid(const Arr: array of TRect): Boolean;
  1257. var
  1258.   I: Integer;
  1259. begin
  1260.   for I := Low(Arr) to High(Arr) do
  1261.     if not RectIsValid(Arr[I]) then
  1262.     begin
  1263.       Result := False;
  1264.       exit;
  1265.     end;
  1266.   Result := True;
  1267. end;
  1268.  
  1269. function RectNull: TRect;
  1270. begin
  1271.   Result := RectSet(0, 0, 0, 0);
  1272. end;
  1273.  
  1274. function RectIsNull(const R: TRect): Boolean;
  1275. begin
  1276.   with R do
  1277.     Result := (Left = 0) and (Right = 0) and (Top = 0) and (Bottom = 0);
  1278. end;
  1279.  
  1280. function RectIsSquare(const R: TRect): Boolean;
  1281. begin
  1282.   Result := RectHeight(R) = RectWidth(R);
  1283. end;
  1284.  
  1285. function RectCentralPoint(const R: TRect): TPoint;
  1286. begin
  1287.   Result.X := R.Left + (RectWidth(R) div 2);
  1288.   Result.Y := R.Top + (RectHeight(R) div 2);
  1289. end;
  1290.  
  1291. function  rectBounds(aLeft,aTop,aWidth,aHeight: Integer): TRect;
  1292. begin
  1293.   Result:=rectSet(aLeft,aTop,aLeft+aWidth,aTop+aHeight);
  1294. end;
  1295.  
  1296.  
  1297. { file functions }
  1298.  
  1299. procedure fileShredder(const Filename: String);
  1300. var
  1301.   aFile : Integer;
  1302.   aSize : Integer;
  1303.   P     : Pointer;
  1304. begin
  1305.   aSize:=fileSize(Filename);
  1306.   aFile:=FileOpen(FileName,fmOpenReadWrite);
  1307.   try
  1308.     Getmem(P,aSize);
  1309.     fillchar(P^,aSize,'X');
  1310.     FileWrite(aFile,P^,aSize);
  1311.     Freemem(P,aSize);
  1312.   finally
  1313.     FileClose(aFile);
  1314.     DeleteFile(Filename);
  1315.   end;
  1316. end;
  1317.  
  1318. function fileSize(const FileName: String): LongInt;
  1319. var
  1320.   SearchRec       : TSearchRec;
  1321. begin                                       { !Win32! -> GetFileSize }
  1322.   if FindFirst(FileName,faAnyFile,SearchRec)=0
  1323.     then Result:=SearchRec.Size
  1324.     else Result:=0;
  1325. end;
  1326.  
  1327. function fileWildcard(const Filename: String): Boolean;
  1328. begin
  1329.   Result:=(Pos('*',Filename)<>0) or (Pos('?',Filename)<>0);
  1330. end; 
  1331.  
  1332. {$IFDEF Win32}
  1333. function fileTemp(const aExt: String): String;
  1334. var
  1335.   Buffer: array[0..1023] of Char;
  1336.   aFile : String;
  1337. begin
  1338.   GetTempPath(Sizeof(Buffer)-1,Buffer);
  1339.   GetTempFileName(Buffer,'TMP',0,Buffer);
  1340.   SetString(aFile, Buffer, StrLen(Buffer));
  1341.   Result:=ChangeFileExt(aFile,aExt);
  1342.   RenameFile(aFile,Result);
  1343. end;
  1344.  
  1345. function fileExec(const aCmdLine: String; aHide, aWait: Boolean): Boolean;
  1346. var
  1347.   StartupInfo : TStartupInfo;
  1348.   ProcessInfo : TProcessInformation;
  1349. begin
  1350.   {setup the startup information for the application }
  1351.   FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
  1352.   with StartupInfo do
  1353.   begin
  1354.     cb:= SizeOf(TStartupInfo);
  1355.     dwFlags:= STARTF_USESHOWWINDOW or STARTF_FORCEONFEEDBACK;
  1356.     if aHide then wShowWindow:= SW_HIDE
  1357.              else wShowWindow:= SW_SHOWNORMAL;
  1358.   end;
  1359.  
  1360.   Result := CreateProcess(nil,PChar(aCmdLine), nil, nil, False,
  1361.                NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo);
  1362.   if aWait then
  1363.      if Result then
  1364.      begin
  1365.        WaitForInputIdle(ProcessInfo.hProcess, INFINITE);
  1366.        WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
  1367.      end;
  1368. end;
  1369.  
  1370. function  fileLongName(const aFile: String): String;
  1371. var
  1372.   aInfo: TSHFileInfo;
  1373. begin
  1374.   if SHGetFileInfo(PChar(aFile),0,aInfo,Sizeof(aInfo),SHGFI_DISPLAYNAME)<>0 then
  1375.      Result:=StrPas(aInfo.szDisplayName)
  1376.   else
  1377.      Result:=aFile;
  1378. end;
  1379.  
  1380. function  fileShortName(const aFile: String): String;
  1381. var
  1382.   aTmp: array[0..255] of char;
  1383. begin
  1384.   if GetShortPathName(PChar(aFile),aTmp,Sizeof(aTmp)-1)=0 then
  1385.      Result:=aFile
  1386.   else
  1387.      Result:=StrPas(aTmp);
  1388. end;
  1389.  
  1390. {$ENDIF}
  1391.  
  1392. function ExtractName(const Filename: String): String;
  1393. var
  1394.   aExt : String;
  1395.   aPos : Integer;
  1396. begin
  1397.   aExt:=ExtractFileExt(Filename);
  1398.   Result:=ExtractFileName(Filename);
  1399.   if aExt <> '' then
  1400.   begin
  1401.     aPos:=Pos(aExt,Result);
  1402.     if aPos>0 then
  1403.        Delete(Result,aPos,Length(aExt));
  1404.   end;
  1405. end;
  1406.  
  1407.  
  1408. { date calculations }
  1409.  
  1410. function  dateYear(D: TDateTime): Integer;
  1411. var
  1412.   Year,Month,Day : Word;
  1413. begin
  1414.   DecodeDate(D,Year,Month,Day);
  1415.   Result:=Year;
  1416. end;
  1417.  
  1418. function  dateMonth(D: TDateTime): Integer;
  1419. var
  1420.   Year,Month,Day : Word;
  1421. begin
  1422.   DecodeDate(D,Year,Month,Day);
  1423.   Result:=Month;
  1424. end;
  1425.  
  1426. function  dateBeginOfYear(D: TDateTime): TDateTime;
  1427. var
  1428.   Year,Month,Day : Word;
  1429. begin
  1430.   DecodeDate(D,Year,Month,Day);
  1431.   Result:=EncodeDate(Year,1,1);
  1432. end;
  1433.  
  1434. function  dateEndOfYear(D: TDateTime): TDateTime;
  1435. var
  1436.   Year,Month,Day : Word;
  1437. begin
  1438.   DecodeDate(D,Year,Month,Day);
  1439.   Result:=EncodeDate(Year,12,31);
  1440. end;
  1441.  
  1442. function  dateBeginOfMonth(D: TDateTime): TDateTime;
  1443. var
  1444.   Year,Month,Day : Word;
  1445. begin
  1446.   DecodeDate(D,Year,Month,Day);
  1447.   Result:=EncodeDate(Year,Month,1);
  1448. end;
  1449.  
  1450. function  dateEndOfMonth(D: TDateTime): TDateTime;
  1451. var
  1452.   Year,Month,Day : Word;
  1453. begin
  1454.   DecodeDate(D,Year,Month,Day);
  1455.   if Month=12 then
  1456.   begin
  1457.     Inc(Year);
  1458.     Month:=1;
  1459.   end else
  1460.     Inc(Month);
  1461.   Result:=EncodeDate(Year,Month,1)-1;
  1462. end;
  1463.  
  1464. function dateWeekOfYear(D: TDateTime): Integer; { Armin Hanisch }
  1465. const
  1466.   t1: array[1..7] of ShortInt = ( -1,  0,  1,  2,  3, -3, -2);
  1467.   t2: array[1..7] of ShortInt = ( -4,  2,  1,  0, -1, -2, -3);
  1468. var
  1469.   doy1,
  1470.   doy2    : Integer;
  1471.   NewYear : TDateTime;
  1472. begin
  1473.   NewYear:=dateBeginOfYear(D);
  1474.   doy1 := dateDayofYear(D) + t1[DayOfWeek(NewYear)];
  1475.   doy2 := dateDayofYear(D) + t2[DayOfWeek(D)];
  1476.   if doy1 <= 0 then
  1477.     Result := dateWeekOfYear(NewYear-1)
  1478.   else if (doy2 >= dateDayofYear(dateEndOfYear(NewYear))) then
  1479.     Result:= 1
  1480.   else
  1481.     Result:=(doy1-1) div 7+1;
  1482. end;
  1483.  
  1484. function dateDayOfYear(D: TDateTime): Integer;
  1485. begin
  1486.   Result:=Trunc(D-dateBeginOfYear(D))+1;
  1487. end;
  1488.  
  1489. function dateDayOfWeek(D: TDateTime): TDayOfWeek;
  1490. begin
  1491.   Result:=TDayOfWeek(Pred(DayOfWeek(D)));
  1492. end;
  1493.  
  1494. function dateLeapYear(D: TDateTime): Boolean;
  1495. var
  1496.   Year,Month,Day: Word;
  1497. begin
  1498.   DecodeDate(D,Year,Month,Day);
  1499.   Result:=(Year mod 4 = 0) and ((Year mod 100 <> 0) or (Year mod 400 = 0));
  1500. end;
  1501.  
  1502. function dateBeginOfQuarter(D: TDateTime):TDateTime;
  1503. var
  1504.   Year,Month,Day : Word;
  1505. begin
  1506.   DecodeDate(D,Year,Month,Day);
  1507.   Result:=EncodeDate(Year,((Month-1 div 3) * 3)+1,1);
  1508. end;
  1509.  
  1510. function dateEndOfQuarter(D: TDateTime): TDateTime;
  1511. begin
  1512.   Result:=dateBeginOfQuarter(dateBeginOfQuarter(D)+(3*31))-1;
  1513. end;
  1514.  
  1515. function dateBeginOfWeek(D: TDateTime; Weekday: Integer): TDateTime;
  1516. begin
  1517.   Result:=D;
  1518.   while DayOfWeek(Result)<>Weekday do Result:=Result-1;
  1519. end;
  1520.  
  1521. function dateDaysInMonth(D: TDateTime): Integer;
  1522. const
  1523.   DaysPerMonth: array[1..12] of Byte= (31,28,31,30,31,30,31,31,30,31,30,31);
  1524. var
  1525.   Month: Integer;
  1526. begin
  1527.   Month:=dateMonth(D);
  1528.   Result:=DaysPerMonth[Month];
  1529.   if (Month=2) and dateLeapYear(D) then Inc(Result);
  1530. end;
  1531.  
  1532. function dateDay(D: TDateTime): Integer;
  1533. var
  1534.   Year,Month,Day : Word;
  1535. begin
  1536.   DecodeDate(D,Year,Month,Day);
  1537.   Result:=Day;
  1538. end;
  1539.  
  1540. function dateQuicken(D: TDateTime; Key: Char): TDateTime;
  1541. const
  1542.  {$IFDEF German}
  1543.   _ToDay    = 'H';
  1544.   _PrevYear = 'J';
  1545.   _NextYear = 'R';
  1546.   _PrevMonth= 'M';
  1547.   _NextMonth= 'T';
  1548.  {$ELSE}
  1549.   _ToDay    = 'H';      { if someone knows US keys, please tell us }
  1550.   _PrevYear = 'J';
  1551.   _NextYear = 'R';
  1552.   _PrevMonth= 'M';
  1553.   _NextMonth= 'T';
  1554.  {$ENDIF}
  1555.  
  1556. begin
  1557.   case Upcase(Key) of                     { Quicken Date Fast Keys }
  1558.     '+'        : Result := D+1;
  1559.     '-'        : Result := D-1;
  1560.     _ToDay     : Result := Date;
  1561.     _PrevYear  : if D <> dateBeginOfYear(D)  then Result:=dateBeginOfYear(D)
  1562.                                              else Result:=dateBeginOfYear(D-1);
  1563.     _NextYear  : if D <> dateEndOfYear(D)    then Result:=dateEndOfYear(D)
  1564.                                              else Result:=dateEndOfYear(Date+1);
  1565.     _PrevMonth : if D <> dateBeginOfMonth(D) then Result:=dateBeginOfMonth(D)
  1566.                                              else Result:=dateBeginOfMonth(D-1);
  1567.     _NextMonth : if D <> dateEndOfMonth(D)   then Result:=dateEndOfMonth(D)
  1568.                                              else Result:=dateEndOfMonth(D+1);
  1569.     else Result := D;
  1570.   end;
  1571. end;
  1572.  
  1573. { time functions }
  1574.  
  1575. function  timeHour(T: TDateTime): Integer;
  1576. var
  1577.   Hour,Minute,Sec,Sec100: Word;
  1578. begin
  1579.   DecodeTime(T,Hour,Minute,Sec,Sec100);
  1580.   Result:=Hour;
  1581. end;
  1582.  
  1583. function  timeMin(T: TDateTime): Integer;
  1584. var
  1585.   Hour,Minute,Sec,Sec100: Word;
  1586. begin
  1587.   DecodeTime(T,Hour,Minute,Sec,Sec100);
  1588.   Result:=Minute;
  1589. end;
  1590.  
  1591. function  timeSec(T: TDateTime): Integer;
  1592. var
  1593.   Hour,Minute,Sec,Sec100: Word;
  1594. begin
  1595.   DecodeTime(T,Hour,Minute,Sec,Sec100);
  1596.   Result:=Sec;
  1597. end;
  1598.  
  1599. function  timeToInt(T: TDateTime): Integer;
  1600. begin
  1601.   Result:=Trunc((MSecsPerday * T) / 1000);
  1602. end;
  1603.  
  1604. {$IFDEF Win32}
  1605. function  timeZoneOffset: Integer;
  1606. var
  1607.   aTimeZoneInfo : TTimeZoneInformation;
  1608. begin
  1609.   if GetTimeZoneInformation(aTimeZoneInfo)<>-1 then
  1610.      Result := aTimeZoneInfo.Bias
  1611.   else
  1612.      Result := 0;
  1613. end;
  1614. {$ENDIF}
  1615.  
  1616. { Communications Functions }
  1617.  
  1618. function  comIsCis(const S: String): Boolean;
  1619. var
  1620.   aSt: String;
  1621.   PreId,
  1622.   PostId: Integer;
  1623. begin
  1624.   Result:=False;
  1625.   if Pos(',',S) > 0 then
  1626.   try
  1627.     aSt:=S;
  1628.     PreId:=StrToInt(strToken(aSt,','));
  1629.     PostId:=StrToInt(aSt);
  1630.     Result:=(PreId > 0) and (PostId > 0);
  1631.   except
  1632.     Result:=False;
  1633.   end;
  1634. end;
  1635.  
  1636. function  comIsInt(const S: String): Boolean;
  1637. var
  1638.   aSt : String;
  1639.   PreId,
  1640.   PostId : String;
  1641. begin
  1642.   try
  1643.     aSt:=S;
  1644.     PreId:=strToken(aSt,'@');
  1645.     PostId:=aSt;
  1646.     Result:=(Length(PreId)>0) and (Length(PostId)>0);
  1647.   except
  1648.     Result:=False;
  1649.   end;
  1650. end;
  1651.  
  1652. { converts a CIS adress to a correct Internet adress }
  1653. function  comCisToInt(const S: String): String;
  1654. var
  1655.   P : Integer;
  1656. begin
  1657.   p:=Pos('INTERNET:',S);
  1658.   if P=1 then
  1659.     Result:=Copy(S,P+1,Length(S))
  1660.   else
  1661.   begin
  1662.     Result:=S;
  1663.     P:=Pos(',',Result);
  1664.     if P>0 then Result[P]:='.';
  1665.     Result:=Result+'@compuserve.com';     { 22.07.96 sb  Error }
  1666.   end;
  1667. end;
  1668.  
  1669. { converts a internet adress to a correct CServe adress }
  1670. function  comIntToCis(const S: String): String;
  1671. var
  1672.   P : Integer;
  1673. begin
  1674.   p:=Pos('@COMPUSERVE.COM',strUpper(S));
  1675.   if p > 0 then
  1676.   begin
  1677.     Result:=strLeft(S,P-1);
  1678.     P:=Pos('.',Result);
  1679.     if P>0 then Result[P]:=',';
  1680.   end else
  1681.     Result:='INTERNET:'+S;
  1682. end;
  1683.  
  1684. { converts a fax adress to a correct CServe adress }
  1685. function  comFaxToCis(const S: String): String;
  1686. begin
  1687.   Result:='FAX:'+S;
  1688. end;
  1689.  
  1690. function comNormFax(const Name, Fax: String): String;
  1691. begin
  1692.   if Name<>'' then
  1693.      Result:=Name+'[fax: '+Name+'@'+strTrim(Fax)+']'
  1694.   else
  1695.      Result:='[fax: '+strTrim(Fax)+']';
  1696. end;
  1697.  
  1698. function  comNormInt(const Name,Int: String): String;
  1699. begin
  1700.   Result:='';
  1701.   if comIsInt(Int) then
  1702.      if Name <> '' then
  1703.         Result := Name + '|smtp: ' + strTrim(Int)
  1704.      else
  1705.         Result := 'smtp: ' + strTrim(Int);
  1706. end;
  1707.  
  1708. function  comNormCis(const Name,Cis: String): String;
  1709. begin
  1710.   Result:='';
  1711.   if Name <> '' then
  1712.      Result := Name + '[compuserve: ' + strTrim(Cis) + ']'
  1713.   else
  1714.      Result := '[compuserve: ' + strTrim(Cis) + ']';
  1715. end;
  1716.  
  1717. function  comNormPhone(const Phone: String): String;
  1718.  
  1719.   function strValueAt(const S:String; At: Integer): String;
  1720.   const
  1721.     Seperator = ',';
  1722.     Str = '"';
  1723.   var
  1724.     j,i: Integer;
  1725.     FSkip : Boolean;
  1726.   begin
  1727.     Result:='';
  1728.     j := 1;
  1729.     i := 0;
  1730.     FSkip:= False;
  1731.     while (i<=At ) and (j<=Length(S)) do
  1732.     begin
  1733.       if (S[j]=Str) then
  1734.          FSkip:=not FSkip
  1735.       else if (S[j]=Seperator) and not FSkip then
  1736.          Inc(i)
  1737.       else if i = At then
  1738.          Result:=Result+S[j];
  1739.       Inc(j);
  1740.     end;
  1741.   end;
  1742.  
  1743. var
  1744.   aNumber,
  1745.   aCountry,
  1746.   aPrefix,
  1747.   aDefault,
  1748.   aLocation  : String;
  1749.  
  1750.   i          : Integer;
  1751. begin
  1752.   aDefault  := '1,"Hamburg","","","40",49,0,0,0,"",1," "';
  1753.   aLocation := strProfile('telephon.ini','Locations','CurrentLocation','');
  1754.   if aLocation <> '' then
  1755.   begin
  1756.     aLocation:=strTokenAt(aLocation,',',0);
  1757.     if aLocation <> '' then
  1758.     begin
  1759.       aLocation:=strProfile('telephon.ini','Locations','Location'+aLocation,'');
  1760.       if aLocation <> '' then
  1761.          aDefault := aLocation;
  1762.     end;
  1763.   end;
  1764.  
  1765.   Result:='';
  1766.   aNumber:=strTrim(Phone);
  1767.   if aNumber <> '' then
  1768.     for i:=Length(aNumber) downto 1 do
  1769.       if not (aNumber[i] in DIGITS) then
  1770.       begin
  1771.         if aNumber[i] <> '+' then aNumber[i] := '-';
  1772.         if i < Length(aNumber) then                    { remove duplicate digits }
  1773.            if aNumber[i]=aNumber[i+1] then
  1774.               Delete(aNumber,i,1);
  1775.       end;
  1776.  
  1777.   if aNumber <> '' then
  1778.   begin
  1779.     if aNumber[1] = '+' then
  1780.        aCountry := strToken(aNumber,'-')
  1781.     else
  1782.        aCountry := '+'+strValueAt(aDefault,5);
  1783.  
  1784.     aNumber:=strTrimChL(aNumber,'-');
  1785.  
  1786.     if aNumber <> '' then
  1787.     begin
  1788.       if strTokenCount(aNumber,'-') > 1 then
  1789.          aPrefix := strTrimChL(strToken(aNumber,'-'),'0')
  1790.       else
  1791.          aPrefix := strValueAt(aDefault,4);
  1792.  
  1793.       aNumber:= strNicePhone(strTrimChA(aNumber,'-'));
  1794.       Result := aCountry + ' ('+aPrefix+') '+aNumber;
  1795.     end;
  1796.   end;
  1797. end;
  1798.  
  1799. { system functions }
  1800.  
  1801. {$IFDEF Win32}
  1802. function sysTempPath: String;
  1803. var
  1804.   Buffer: array[0..1023] of Char;
  1805. begin
  1806.   SetString(Result, Buffer, GetTempPath(Sizeof(Buffer)-1,Buffer));
  1807. end;
  1808. {$ELSE}
  1809. function sysTempPath:String;
  1810. var
  1811.   Buffer: array[0..255] of char;
  1812. begin
  1813.   GetTempFileName(#0,'TMP',0,Buffer);             { 15.07.96 sb }
  1814.   Result:=StrPas(Buffer);
  1815.   DeleteFile(Result);
  1816.   Result:=ExtractFilePath(Result);
  1817. end;
  1818. {$ENDIF}
  1819.  
  1820. procedure sysDelay(aMs: Longint);
  1821. var
  1822.   TickCount       : LongInt;
  1823. begin
  1824.   TickCount:=GetTickCount;
  1825.   while GetTickCount - TickCount < aMs do Application.ProcessMessages;
  1826. end;
  1827.  
  1828. procedure sysBeep;
  1829. begin
  1830.   messageBeep($FFFF);
  1831. end;
  1832.  
  1833. {$IFDEF Win32}
  1834. procedure sysSaverRunning(Active: Boolean);
  1835. var
  1836.   aParam: Longint;
  1837. begin
  1838.   SystemParametersInfo (SPI_SCREENSAVERRUNNING, Word(Active),@aParam,0);
  1839. end;
  1840. {$ENDIF}
  1841.  
  1842. { registry functions }
  1843.  
  1844. {$IFDEF Win32 }
  1845.  
  1846. function regReadString(aKey: HKEY; const Path: String): String;
  1847. var
  1848.   aRegistry : TRegistry;
  1849.   aPath     : String;
  1850.   aValue    : String;
  1851. begin
  1852.   aRegistry:=TRegistry.Create;
  1853.   try
  1854.     with aRegistry do
  1855.     begin
  1856.       RootKey:=aKey;
  1857.       aPath:=Path;
  1858.       aValue:='';
  1859.       while (Length(aPath)>0) and (strLastCh(aPath)<>'\') do
  1860.       begin
  1861.         aValue:=strLastCh(aPath)+aValue;
  1862.         strStripLast(aPath);
  1863.       end;
  1864.       OpenKey(aPath,True);
  1865.       Result:=ReadString(aValue);
  1866.     end;
  1867.   finally
  1868.     aRegistry.Free;
  1869.   end;
  1870. end;
  1871.  
  1872. procedure regWriteString(aKey: HKEY; const Path,Value: String);
  1873. var
  1874.   aRegistry : TRegistry;
  1875.   aPath     : String;
  1876.   aValue    : String;
  1877. begin
  1878.   aRegistry:=TRegistry.Create;
  1879.   try
  1880.     with aRegistry do
  1881.     begin
  1882.       RootKey:=aKey;
  1883.       aPath:=Path;
  1884.       aValue:='';
  1885.       while (Length(aPath)>0) and (strLastCh(aPath)<>'\') do
  1886.       begin
  1887.         aValue:=strLastCh(aPath)+aValue;
  1888.         strStripLast(aPath);
  1889.       end;
  1890.       OpenKey(aPath,True);
  1891.       WriteString(aValue,Value);
  1892.     end;
  1893.   finally
  1894.     aRegistry.Free;
  1895.   end;
  1896. end;
  1897.  
  1898. (*!!!
  1899. function regReadString(aKey: hKey; const Value: String): String;
  1900. var
  1901.   aTmp  : array[0..255] of char;
  1902.   aCb,
  1903.   aType : Integer;
  1904. begin
  1905.   Result:='';
  1906.   if aKey<> 0 then
  1907.   begin
  1908.     aCb:=Sizeof(aTmp)-1;
  1909.    { aData:=@aTmp; }
  1910.     if RegQueryValueEx(aKey,PChar(Value),nil,@aType,@aTmp,@aCb)=ERROR_SUCCESS then
  1911.        if aType=REG_SZ then Result:=String(aTmp);
  1912.   end;
  1913. end; *)
  1914.  
  1915. function regInfoString(const Value: String): String;
  1916. var
  1917.   aKey : hKey;
  1918. begin
  1919.   Result:='';
  1920.   if RegOpenKey(HKEY_LOCAL_MACHINE,REG_CURRENT_VERSION,aKey)=ERROR_SUCCESS then
  1921.   begin
  1922.     Result:=regReadString(aKey,Value);
  1923.     RegCloseKey(aKey);
  1924.   end;
  1925. end;
  1926.  
  1927. function regCurrentUser: String;
  1928. begin
  1929.   Result:=regInfoString(REG_CURRENT_USER);
  1930. end;
  1931.  
  1932. function regCurrentCompany: String;
  1933. begin
  1934.   Result:=regInfoString(REG_CURRENT_COMPANY);
  1935. end;
  1936.  
  1937. {$ENDIF}
  1938.  
  1939. { other stuff }
  1940.  
  1941. function MsgBox(const aTitle,aMsg: String; aFlag: Integer): Integer;
  1942. var
  1943.   ActiveWindow : hWnd;
  1944.   WindowList   : Pointer;
  1945.   TmpA         : array[0..200] of char;
  1946.   TmpB         : array[0..100] of char;
  1947. begin
  1948.   ActiveWindow:=GetActiveWindow;
  1949.   WindowList:= DisableTaskWindows(0);
  1950.   try
  1951.     StrPCopy(TmpB,aTitle);
  1952.     StrPCopy(TmpA,aMsg);
  1953.    {$IFDEF Win32}
  1954.     Result:=Windows.MessageBox(Application.Handle, TmpA, TmpB, aFlag);
  1955.    {$ELSE}
  1956.     Result:=WinProcs.MessageBox(Application.Handle, TmpA, TmpB, aFlag);
  1957.    {$ENDIF}
  1958.   finally
  1959.     EnableTaskWindows(WindowList);
  1960.     SetActiveWindow(ActiveWindow);
  1961.   end;
  1962. end;
  1963.  
  1964. function Question(const Msg: String):Boolean;
  1965. begin
  1966.   if IsWin95 or IsWinNT then
  1967.     Result:=MsgBox(LoadStr(SMsgdlgConfirm),Msg, MB_ICONQUESTION or MB_YESNO)=IDYES
  1968.   else
  1969.     Result:=messageDlg(Msg,mtConfirmation,[mbYes,mbNo],0)=mrYes;
  1970. end;
  1971.  
  1972. procedure Information(const Msg: String);
  1973. begin
  1974.   if IsWin95 or IsWinNT then
  1975.      MsgBox(LoadStr(SMsgdlgInformation), Msg, MB_ICONINFORMATION or MB_OK )
  1976.   else
  1977.      messageDlg(Msg,mtInformation,[mbOk],0);
  1978. end;
  1979.  
  1980. function Confirmation(const Msg: String): Word;
  1981. begin
  1982.   if IsWin95 or IsWinNT then
  1983.      case MsgBox(LoadStr(SMsgDlgConfirm),Msg,MB_ICONQUESTION or MB_YESNOCANCEL) of
  1984.        IDYES    : Result := mrYes;
  1985.        IDNO     : Result := mrNo;
  1986.        IDCANCEL : Result := mrCancel;
  1987.        else       Result := mrCancel;
  1988.      end
  1989.   else
  1990.      Result:=MessageDlg(Msg,mtConfirmation,[mbYes,mbNo,mbCancel],0);
  1991. end;
  1992.  
  1993. { TPersistentRect }
  1994.  
  1995. constructor TPersistentRect.Create;
  1996. begin
  1997.   FRect:=rectSet(10,10,100,20);
  1998. end;
  1999.  
  2000. procedure TPersistentRect.Assign(Source: TPersistent);
  2001. var
  2002.  Value: TPersistentRect;
  2003. begin
  2004.   if Value is TPersistentRect then
  2005.   begin
  2006.     Value:=Source as TPersistentRect;
  2007.     FRect:=rectBounds(Value.Left,Value.Top,Value.Width,Value.Height);
  2008.     exit;
  2009.   end;
  2010.   inherited Assign(Source);
  2011. end;
  2012.  
  2013. procedure TPersistentRect.SetLeft(Value: Integer);
  2014. begin
  2015.   if Value<>Left then
  2016.   begin
  2017.     if Assigned(FOnConvert) then
  2018.        Value:=FOnConvert(Self,Value,False);
  2019.     FRect:=rectBounds(Value,Top,Width,Height);
  2020.   end;
  2021. end;
  2022.  
  2023. procedure TPersistentRect.SetTop(Value: Integer);
  2024. begin
  2025.   if Value<>Top then
  2026.   begin
  2027.     if Assigned(FOnConvert) then
  2028.        Value:=FOnConvert(Self,Value,False);
  2029.     FRect:=rectBounds(Left,Value,Width,Height);
  2030.   end;
  2031. end;
  2032.  
  2033. procedure TPersistentRect.SetHeight(Value: Integer);
  2034. begin
  2035.   if Value<>Height then
  2036.   begin
  2037.     if Assigned(FOnConvert) then
  2038.        Value:=FOnConvert(Self,Value,False);
  2039.     FRect:=rectBounds(Left,Top,Width,Value);
  2040.   end;
  2041. end;
  2042.  
  2043. procedure TPersistentRect.SetWidth(Value: Integer);
  2044. begin
  2045.   if Value<>Width then
  2046.   begin
  2047.     if Assigned(FOnConvert) then
  2048.        Value:=FOnConvert(Self,Value,False);
  2049.     FRect:=rectBounds(Left,Top,Value,Height);
  2050.   end;
  2051. end;
  2052.  
  2053. function  TPersistentRect.GetLeft: Integer;
  2054. begin
  2055.   Result:=FRect.Left;
  2056.   if Assigned(FOnConvert) then
  2057.      Result:=FOnConvert(Self,Result,True);
  2058. end;
  2059.  
  2060. function  TPersistentRect.GetTop: Integer;
  2061. begin
  2062.   Result:=FRect.Top;
  2063.   if Assigned(FOnConvert) then
  2064.      Result:=FOnConvert(Self,Result,True);
  2065. end;
  2066.  
  2067. function  TPersistentRect.GetHeight: Integer;
  2068. begin
  2069.   Result:=rectHeight(FRect);
  2070.   if Assigned(FOnConvert) then
  2071.      Result:=FOnConvert(Self,Result,True);
  2072. end;
  2073.  
  2074. function  TPersistentRect.GetWidth: Integer;
  2075. begin
  2076.   Result:=rectWidth(FRect);
  2077.   if Assigned(FOnConvert) then
  2078.      Result:=FOnConvert(Self,Result,True);
  2079. end;
  2080.  
  2081. {$IFDEF Win32}
  2082.  
  2083. { TPersistentRegistry }
  2084.  
  2085. function TPersistentRegistry.ReadComponent(const Name: String;
  2086.                                  Owner, Parent: TComponent): TComponent;
  2087. var
  2088.   DataSize  : Integer;
  2089.   MemStream : TMemoryStream;
  2090.   Reader    : TReader;
  2091. begin
  2092.   Result := nil;
  2093.   DataSize:=GetDataSize(Name);
  2094.   MemStream := TMemoryStream.Create;
  2095.   try
  2096.     MemStream.SetSize(DataSize);
  2097.     ReadBinaryData(Name,MemStream.Memory^,DataSize);
  2098.     MemStream.Position := 0;
  2099.  
  2100.     Reader := TReader.Create(MemStream, 256);
  2101.     try
  2102.       Reader.Parent := Parent;
  2103.       Result := Reader.ReadRootComponent(nil);
  2104.       if Owner <> nil then
  2105.         try
  2106.           Owner.InsertComponent(Result);
  2107.         except
  2108.           Result.Free;
  2109.           raise;
  2110.         end;
  2111.     finally
  2112.       Reader.Free;
  2113.     end;
  2114.  
  2115.   finally
  2116.     MemStream.Free;
  2117.   end;
  2118. end;
  2119.  
  2120. procedure TPersistentRegistry.WriteComponent(const Name: String; Component: TComponent);
  2121. var
  2122.   MemStream: TMemoryStream;
  2123. begin
  2124.   MemStream := TMemoryStream.Create;
  2125.   try
  2126.     MemStream.WriteComponent(Component);
  2127.     WriteBinaryData(Name, MemStream.Memory^, MemStream.Size);
  2128.   finally
  2129.     MemStream.Free;
  2130.   end;
  2131. end;
  2132.  
  2133. {$ENDIF}
  2134.  
  2135. { TSystemMetric }
  2136.  
  2137. constructor TSystemMetric.Create;
  2138. begin
  2139.   inherited Create;
  2140.   Update;
  2141. end;
  2142.  
  2143. procedure TSystemMetric.Update;
  2144.  
  2145.   function GetSystemPoint(ax,ay: Integer):TPoint;
  2146.   begin
  2147.     Result:=Point(GetSystemMetrics(ax),GetSystemMetrics(ay));
  2148.   end;
  2149.  
  2150. begin
  2151.   FMenuHeight    :=GetSystemMetrics(SM_CYMENU);
  2152.   FCaptionHeight :=GetSystemMetrics(SM_CYCAPTION);
  2153.   FBorder        :=GetSystemPoint(SM_CXBORDER,SM_CYBORDER);
  2154.   FFrame         :=GetSystemPoint(SM_CXFRAME,SM_CYFRAME);
  2155.   FDlgFrame      :=GetSystemPoint(SM_CXDLGFRAME,SM_CYDLGFRAME);
  2156.   FBitmap        :=GetSystemPoint(SM_CXSIZE,SM_CYSIZE);
  2157.   FHScroll       :=GetSystemPoint(SM_CXHSCROLL,SM_CYHSCROLL);
  2158.   FVScroll       :=GetSystemPoint(SM_CXVSCROLL,SM_CYVSCROLL);
  2159.   FThumb         :=GetSystemPoint(SM_CXHTHUMB,SM_CYVTHUMB);
  2160.   FFullScreen    :=GetSystemPoint(SM_CXFULLSCREEN,SM_CYFULLSCREEN);
  2161.   FMin           :=GetSystemPoint(SM_CXMIN,SM_CYMIN);
  2162.   FMinTrack      :=GetSystemPoint(SM_CXMINTRACK,SM_CYMINTRACK);
  2163.   FCursor        :=GetSystemPoint(SM_CXCURSOR,SM_CYCURSOR);
  2164.   FIcon          :=GetSystemPoint(SM_CXICON,SM_CYICON);
  2165.   FDoubleClick   :=GetSystemPoint(SM_CXDOUBLECLK,SM_CYDOUBLECLK);
  2166.   FIconSpacing   :=GetSystemPoint(SM_CXICONSPACING,SM_CYICONSPACING);
  2167. end;
  2168.  
  2169. { TDesktopCanvas }
  2170.  
  2171. constructor TDesktopCanvas.Create;
  2172. begin
  2173.   inherited Create;
  2174.   DC:=GetDC(0);
  2175.   Handle:=DC;
  2176. end;
  2177.  
  2178. destructor  TDesktopCanvas.Destroy;
  2179. begin
  2180.   Handle:=0;
  2181.   ReleaseDC(0, DC);
  2182.   inherited Destroy;
  2183. end;
  2184.  
  2185. {$IFNDEF Win32}
  2186.  
  2187. procedure DoneXProcs; far;
  2188. begin
  2189.   SysMetric.Free;
  2190. end;
  2191.  
  2192. {$ENDIF}
  2193.  
  2194. initialization
  2195.  
  2196.   Randomize;
  2197.  
  2198.   SysMetric := TSystemMetric.Create;
  2199.   IsWin95   := (GetVersion and $FF00) >= $5F00;
  2200.   IsWinNT   := (GetVersion < $80000000);
  2201.   IsFabula  := nil;
  2202.  
  2203. {$IFDEF Win32}
  2204.   xLanguage := (LoWord(GetUserDefaultLangID) and $3ff);
  2205.   case xLanguage of
  2206.     LANG_GERMAN    : xLangOfs := 70000;
  2207.     LANG_ENGLISH   : xLangOfs := 71000;
  2208.     LANG_SPANISH   : xLangOfs := 72000;
  2209.     LANG_RUSSIAN   : xLangOfs := 73000;
  2210.     LANG_ITALIAN   : xLangOfs := 74000;
  2211.     LANG_FRENCH    : xLangOfs := 75000;
  2212.     LANG_PORTUGUESE: xLangOfs := 76000;
  2213.     else             xLangOfs := 71000;
  2214.   end;
  2215. {$ENDIF}
  2216.  
  2217. {$IFDEF Win32}
  2218. finalization
  2219.   SysMetric.Free;
  2220. {$ELSE}
  2221.   AddExitProc(DoneXProcs);
  2222. {$ENDIF}
  2223.  
  2224. end.
  2225.  
  2226.  
  2227.